Collection of Tools & Utilities/Collection of Tools and Utilities.iso/system/ifp1s158.zip/IFPCOMON.PAS

Pascal/Delphi Source File | 1993-08-15 | 13KB | 636 lines

unit ifpcomon;

interface

uses Crt, Dos, ifpglobl, ifpextrn;

function getkey2: char2;
function getnum: word;
procedure caption1(a: string);
procedure caption2(a: string);
procedure caption3(a : string);
function nocarry(regs: registers) : boolean;
function hex(a : word; b : byte) : string;
procedure unknown(a: string; b: word; c: byte);
procedure yesorno(a : boolean);
procedure yesorno2(a: boolean);
procedure yesorno3(a: boolean);
procedure dontknow;
procedure dontknow2;
procedure segofs(a, b : word);
function showchar(a : char) : char;
function power2(y: word): longint;
procedure pause1;
procedure pause2;
procedure pause3(extra: integer);
procedure pause4(direc: directions; var ch2: char2);
procedure pause5(direc: directions; var ch2: char2);
function bin4(a: byte) : string;
procedure offoron(a: string; b: boolean);
procedure zeropad(a: word);
procedure zeropad3(a: word);
procedure showvers;
function cbw(a, b: byte) : word;
function bin16(a: word) : string;
procedure drvname(a: byte);
procedure media(a, b: byte);
procedure pagenameclr;
procedure Intr(intno: byte; var regs: registers);
procedure MsDos(var regs: registers);
procedure TextColor(color: byte);
procedure TextBackground(color: byte);
function unBCD(b: byte): byte;
function addzero(b: byte): string;
procedure modeinfo(var vidmode, vidlen, vidpg: byte; var vidwid: word);
procedure box;
procedure center(s: string);
function EMSOK: boolean;

implementation

uses ifpscrpt, ifphelp;

function getkey2: char2;
  var
    c: char;
    c2: char2;

  begin
  c:=ReadKey;
  if c = #0 then
    getkey2:=c + ReadKey
  else
    getkey2:=c;
  end; {getkey2}

{^Make sure number entered, not any letters}
function getnum: word;
  var
    inpchar: char;
    number_string: string[2];
    temp, position, code: word;
    row, col: byte;
    finish: boolean;

  begin
  row:=WhereY;
  col:=WhereX;
  Write(' ':3);
  GotoXY(col, row);
  temp:=99;
  finish:=false;
  position:=0;
  number_string:='';
  TextColor(LightGray);
  repeat
    inpchar:=ReadKey;
    case inpchar of
      '0'..'9':if position < 2 then
        begin
        Inc(position);
        Inc(number_string[0]);
        number_string[position]:=inpchar;
        Write(inpchar)
        end;
      #8: if position > 0 then
        begin
        Dec(position);
        Dec(number_string[0]);
        Write(^H' '^H)
        end;
      #27: if number_string = '' then
          finish:=true
        else
          begin
          number_string:='';
          GotoXY(col, row);
          ClrEol;
          position:=0
          end;
      #13: finish:=true
    end {case}
  until finish;
  if number_string <> '' then
    Val(number_string, temp, code)
  else
    temp:=999;
  getnum:=temp
  end; {getnum}

procedure caption1(a: string);
  begin
  textcolor(LightGray);
  Write(a);
  textcolor(LightCyan)
  end; {caption1}

procedure caption2(a: string);
  const
    capterm = ': ';

  var
    i: byte;
    xbool: boolean;

  begin
  i:=length(a);
  while (i > 0) and (a[i] = ' ') do
    dec(i);
  insert(capterm, a, i + 1);
  caption1(a)
  end; {caption2}

procedure caption3(a : string);
  begin
  caption2('  ' + a)
  end; {caption3}

function nocarry(regs: registers) : boolean;
  begin
  nocarry:=regs.flags and fcarry = $0000
  end; {nocarry}

function hex(a : word; b : byte) : string;
  const
    digit : array[$0..$F] of char = '0123456789ABCDEF';

  var
    i : byte;
    xstring : string;

  begin
  xstring:='';
  for i:=1 to b do
    begin
    insert(digit[a and $000F], xstring, 1);
    a:=a shr 4
    end;
  hex:=xstring
  end; {hex}

procedure unknown(a: string; b: word; c: byte);
  begin
  Writeln('(unknown', ' ', a, ' ', hex(b, c), ')')
  end; {unknown}

procedure yesorno(a : boolean);
  begin
  if a then
    Writeln('yes')
  else
    Writeln('no')
  end; {yesorno}

procedure yesorno2(a: boolean);
  begin
  if a then
    Write('yes')
  else
    Write('no')
  end; {yesorno2}

procedure YesOrNo3(a: boolean);
  begin
  YesOrNo2(a);
  if not a then
    Write(' ');
  end;

procedure dontknow;
  begin
  Writeln('(unknown)')
  end; {dontknow}

procedure dontknow2;
  begin
  Write('(unknown)')
  end; {dontknow2}

procedure segofs(a, b : word);
  begin
  Write(hex(a, 4), ':', hex(b, 4))
  end; {segofs}

function showchar(a : char) : char;
  begin
  if a in pchar then
    showchar:=a
  else
    showchar:='.'
  end; {showchar}

function power2(y: word): longint;
  begin
  power2:=Trunc(exp((y * 1.0) * ln(2.0)))
  end;

procedure pause1;
  var
    xbyte : byte;
    xchar : char2;
    SaveX, SaveY: byte;

  begin
  xbyte:=TextAttr;
  endit:=false;
  TextColor(Cyan);
  SaveX:=WhereX;
  SaveY:=WhereY;
  Write('( for more)');
  if PrinterRec.Mode = 'A' then
    ScreenPrint(Pg, PgNames[Pg], VerNum)
  else
    begin
    repeat
      xchar:=getkey2;
      if xchar = #0#25 then
        begin
        ScreenPrint(Pg, PgNames[Pg], VerNum);
        xchar:=#0#0
        end;
      if xchar = #0#$3B then
        begin
        HelpScreen(Pg, HelpVersion);
        xchar:=#0#0
        end;
    until xchar <> #0#0;
    if xchar <> #0#80 then
      begin
      endit:=true;
      c2:=xchar
      end;
    end;
  TextAttr:=xbyte;
  GotoXY(SaveX, SaveY);
  Write('            ')
  end; {pause1}

procedure pause2;
  var
    xbyte : byte;

  begin
  if WhereY + hi(WindMin) > hi(WindMax) then
    begin
    xbyte:=TextAttr;
    TextColor(Cyan);
    pause1;
    if not endit then
      begin
      Clrscr;
      Writeln('(continued)');
      end;
    TextAttr:=xbyte
    end
  end; {pause2}

procedure pause3(extra: integer);
  var
    xbyte: byte;
  begin
  endit:=false;
  if WhereY + Hi(WindMin) + Abs(extra) > Hi(WindMax) then
    begin
    xbyte:=TextAttr;
    TextColor(Cyan);
    pause1;
    if not endit then
      begin
      ClrScr;
      if extra < 0 then
        Writeln('(continued)');
      end;
    TextAttr:=xbyte
    end
  end; {pause3}

procedure pause4(Direc: Directions; var ch2: char2);
  var
    xbyte : byte;
    xchar : char2;
    SaveX, SaveY: byte;

  begin
  xbyte:=TextAttr;
  endit:=false;
  TextColor(Cyan);
  SaveX:=WhereX;
  SaveY:=WhereY;
  case Direc of
    none:   Write('(any key)');
    up:     Write('( for more)');
    down:   Write('( for more)');
    updown: Write('( or  for more)')
  end;
  repeat
    if PrinterRec.Mode = 'A' then
      if Direc = up then
        xchar:=#0#81
      else
        begin
        ScreenPrint(Pg, PgNames[Pg], VerNum);
        xchar:=#0#80;
        end
    else
      begin
      xchar:=getkey2;
      if xchar = #0#25 then
        begin
        ScreenPrint(Pg, Pgnames[Pg], VerNum);
        xchar:=#0#0
        end;
      if xchar = #0#$3B then
        begin
        HelpScreen(Pg, HelpVersion);
        xchar:=#0#0
        end;
      end;
  until xchar <> #0#0;
  if (xchar[1] <> #0) or
    ((xchar[1] = #0) and (not (xchar[2] in [#80, #72]))) then
    begin
    endit:=true;
    c2:=xchar;
    end;
  TextAttr:=xbyte;
  GotoXY(SaveX, SaveY);
  Write('                 ');
  ch2:=xchar;
  end; {pause4}

procedure pause5(direc: directions; var ch2: char2);
  var
    xbyte : byte;

  begin
  ch2:=#0#0;
  if WhereY + Hi(WindMin) > Hi(WindMax) then
    begin
    xbyte:=TextAttr;
    TextColor(Cyan);
    Pause4(direc, ch2);
    if not endit then
      Clrscr;
    TextAttr:=xbyte
    end
  end; {pause5}

function bin4(a : byte) : string;
  const
    digit : array[0..1] of char = '01';

  var
    xstring : string;
    i : byte;

  begin
  xstring:='';
  for i:=3 downto 0 do
    begin
    insert(digit[a mod 2], xstring, 1);
    a:=a shr 1
    end;
  bin4:=xstring
  end; {bin4}

procedure offoron(a : string; b : boolean);
  begin
  caption3(a);
  if b then
    Write('on')
  else
    Write('off')
  end; {offoron}

procedure zeropad(a : word);
  begin
  if a < 10